;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted.  Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;; 
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;; 
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;;   CommonLoops Coordinator
;;;   Xerox Artifical Intelligence Systems
;;;   2400 Hanover St.
;;;   Palo Alto, CA 94303
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;

(in-package 'pcl)

;;;
;;; ADD-NAMED-CLASS  proto-class name local-supers local-slot-slotds extra
;;; protocol: class-definition
;;;
;;; Creates or updates the definition of a class with a named class.  If
;;; there is already a class named name, calls class-for-redefinition to
;;; find out which class to use for the redefinition.  Once it has a class
;;; object to use it stores the relevant information from the ds-options in
;;; the class and calls add-class to add the class to the class
;;; lattice.
;;; 
(defmeth add-named-class ((proto-class basic-class) name
						    local-supers
						    local-slot-slotds
						    extra)
  ;; First find out if there is already a class with this name.
  ;; If there is, call class-for-redefinition to get the class
  ;; object to use for the new definition.  If there is no exisiting
  ;; class we just make a new instance.
  (let* ((existing (class-named name t))
	 (class (if existing
		    (class-for-redefinition existing proto-class name 
					    local-supers local-slot-slotds
					    extra)
		    (make (class-of proto-class)))))

    (setq local-supers
	  (mapcar
	    #'(lambda (ls)
		(or (class-named ls t)
		    (error "~S was specified as the name of a local-super~%~
                            for the class named ~S.  But there is no class~%~
                            class named ~S." ls name ls)))
	    local-supers))
    
    (setf (class-name class) name)
    (setf (class-ds-options class) extra)	;This is NOT part of the
						;standard protocol.
   
    (add-class class local-supers local-slot-slotds extra)
    
    (setf (class-named name) class)
    name))

(defmeth add-class
	 ((class essential-class) new-local-supers new-local-slots extra)
  (ignore extra)
  (let ((old-local-supers (class-local-supers class))
	(old-local-slots (class-local-slots class)))
    
    (setf (class-local-supers class) new-local-supers)
    (setf (class-local-slots class) new-local-slots)

    (if (and old-local-supers			;*** YUCH!! There is a bug
	     new-local-supers			;*** when old and new are ()
	     (equal old-local-supers new-local-supers))
	(if (and old-local-slots
		 new-local-slots
		 (equal old-local-slots new-local-slots))
	    ;; If the supers haven't changed, and the slots haven't changed
	    ;; then not much has changed and we don't have to do anything.
	    ()
	    ;; If only the slots have changed call slots-changed.
	    (slots-changed class old-local-slots extra t))
	;; If the supers have changed, first update local-supers and
	;; direct-subclasses of all the people involved.  Then call
	;; supers-changed.
	(progn
	  (dolist (nls new-local-supers)
	    (unless (memq nls old-local-supers)
	      (check-super-meta-class-compatibility class nls)
	      (push class (class-direct-subclasses nls))))
	  (dolist (ols old-local-supers)
	    (unless (memq ols new-local-supers)
	      (setf (class-direct-subclasses ols)
		    (delq class (class-direct-subclasses ols)))))
	  (supers-changed class old-local-supers old-local-slots extra t)))))


(defmeth supers-changed ((class basic-class)
			 old-local-supers
			 old-local-slots
			 extra
			 top-p)
  (ignore old-local-slots)
  (let ((cpl (compute-class-precedence-list class
					    (class-local-supers class))))
    (setf (class-class-precedence-list class) cpl)
    (update-slots--class class cpl)		         ;This is NOT part of
						         ;the essential-class
						         ;protocol.
    (dolist (sub-class (class-direct-subclasses class))
      (supers-changed sub-class
		      (class-local-supers sub-class)
		      (class-local-slots sub-class)
		      extra
		      nil))
    (when top-p                                          ;This is NOT part of
      (update-method-inheritance class old-local-supers));the essential-class
						         ;protocol.
    ))

(defmeth slots-changed ((class basic-class)
			old-local-slots
			extra
			top-p)
  (ignore top-p old-local-slots)
  ;; When this is called, class should have its local-supers and
  ;; local-slots slots filled in properly.
  (update-slots--class class (class-class-precedence-list class))
  (dolist (sub-class (class-direct-subclasses class))
    (slots-changed sub-class (class-local-slots sub-class) extra nil)))

(defun update-slots--class (class cpl)
  (let ((obsolete-class nil))
    (multiple-value-bind (instance-slots non-instance-slots)
	(collect-slotds class (class-local-slots class) () cpl)
      ;; If there is a change in the shape of the instances then the
      ;; old class is now obsolete.  Make a copy of it, then fill
      ;; ourselves in properly and obsolete it.
      (when (and (class-has-instances-p class)
		 (not (same-shape-slots-p (class-instance-slots class)
					  instance-slots)))
	(setq obsolete-class (copy-class class)))
      (setf (class-no-of-instance-slots class) (length instance-slots))
      (setf (class-instance-slots class) instance-slots)
      (setf (class-non-instance-slots class) non-instance-slots)
      (when obsolete-class
	(flush-class-caches class)
	(make-class-obsolete class (copy-class class))))))

;;;
;;; CLASS-FOR-REDEFINITION old-class proto-class name ds-options slotds
;;; protocol: class definition
;;; 
;;; When a class is being defined, and a class with that name already exists
;;; a decision must be made as to what to use for the new class object, and
;;; whether to update the old class object.  For this, class-for-redefinition
;;; is called with the old class object, the prototype of the new class, and
;;; the name ds-options and slotds corresponding to the new definition.
;;; It should return the class object to use as the new definition.  It is
;;; OK for this to be old-class if that is appropriate.
;;; 
(defmeth class-for-redefinition ((old-class essential-class)
				 proto-class
				 name
				 local-supers
				 local-slot-slotds
				 extra)
  (ignore local-supers local-slot-slotds extra)
  (cond ((not (compatible-meta-class-change-p old-class proto-class))
	 (error "The class ~A already exists; its class is ~A.~%~
		 The :class argument in the defstruct is ~A.
		 This is an incompatible meta-class change.~%~"
		name
		(class-name (class-of old-class))
		(class-name (class-of proto-class))))
	(t (values old-class (copy-class old-class)))))

(defmeth update-method-inheritance ((class basic-class) old-local-supers)
  ;; In the absence of method combination, we have to flush all the
  ;; discriminators which we used to inherit and all the discriminators
  ;; which we now inherit.
  (let ((old-mil
	  (compute-method-inheritance-list class old-local-supers))
	(new-mil
	  (compute-method-inheritance-list class
					   (class-local-supers class)))
	(discriminators ())
	(combined-discriminators ()))
    (dolist (old-donor old-mil)
      (when (setq discriminators (class-direct-discriminators old-donor))
	(dolist (old-discriminator discriminators)	  
	  (flush-discriminator-caches old-discriminator)
	  (when (methods-combine-p old-discriminator)
	    (pushnew old-discriminator combined-discriminators)))))
    (dolist (new-donor new-mil)
      (when (setq discriminators (class-direct-discriminators new-donor))
	(unless (memq new-donor old-mil)
	  (dolist (new-discriminator discriminators)
	    (when (methods-combine-p new-discriminator)
	      (pushnew new-discriminator combined-discriminators))
	    (flush-discriminator-caches new-discriminator)))))
    (when (fboundp 'combine-methods)		         ;***
      (COMBINE-METHODS CLASS COMBINED-DISCRIMINATORS)))) ;***


(defmeth discriminator-changed ((discriminator essential-discriminator)
				method
				added-p)
  (ignore method added-p)
  (make-discriminating-function discriminator)
  (flush-discriminator-caches discriminator))


(defun make-class-obsolete (class obsolete-class)
  (setf (class-wrapper-class (class-wrapper obsolete-class)) obsolete-class)
  (setf (class-wrapper class) nil)
  (setf (class-local-supers obsolete-class) (list class))
  (setf (class-class-precedence-list obsolete-class)
        (cons obsolete-class (class-class-precedence-list class)))
  (setf (class-name obsolete-class)
	(symbol-append "obsolete-" (class-name class)))
  (setf (iwmc-class-class-wrapper obsolete-class)
        (wrapper-of (class-named 'obsolete-class)))
  obsolete-class)

(defun copy-class (class) 
  (let* ((no-of-instance-slots (class-no-of-instance-slots (class-of class)))
         (new-class (%allocate-instance--class no-of-instance-slots)))
    (setf (iwmc-class-class-wrapper new-class)
	  (iwmc-class-class-wrapper class))
    (iterate ((i from 0 below no-of-instance-slots))
      (setf (get-static-slot--class new-class i)
	    (get-static-slot--class class i)))
    (setf (iwmc-class-dynamic-slots new-class)
          (copy-list (iwmc-class-dynamic-slots class)))
    new-class))

(defun wrapper-of (class)
  (or (class-wrapper class)
      (setf (class-wrapper class) (make-class-wrapper class))))

(defmeth collect-slotds ((class basic-class) local-slots include-slots cpl
			 &aux temp)
  (macrolet ((shadow-or-add-slot (slotd slotds &optional replace-fn add-form)
               `(if (setq temp (slotd-member (slotd-name ,slotd) ,slotds))
		    ,(and replace-fn `(,replace-fn temp ',slotd))
                    ,(or add-form `(push ,slotd ,slotds)))))
    (let ((all-slots ())
          (instance-slots ())
          (non-instance-slots ()))
      ;; Go through the class-precedence-list pushing all the slots onto the
      ;; same list (all-slots).  Do shadowing (using shadow-or-add-slotd), by
      ;; checking to see if a slot with the same name is already in the list
      ;; and if it is replacing its slotd with the new one.
      ;; Note that the kind of shadowing that makes a slot change its
      ;; allocation from :instance to :dynamic happens the same way all
      ;; shadowing happens because we merge all the slots into one list and
      ;; then separate them into instance slots and non-instance slots.
      (iterate ((local-slot in local-slots))
        (shadow-or-add-slot local-slot all-slots))
      (iterate ((ls in (cdr cpl)))
        (iterate ((instance-slot in (class-instance-slots ls)))
          (shadow-or-add-slot instance-slot all-slots))
        (iterate ((non-instance-slot in (class-non-instance-slots ls)))
          (shadow-or-add-slot non-instance-slot all-slots)))
      (iterate ((include-slot in include-slots))
        (shadow-or-add-slot include-slot all-slots
	  rplaca
          (error
	    "The slot ~S appeared in the :include option of the defstruct~%~
             for the class ~S. But this slot does not appear in any of the~%~
             class's superclasses."
	    (slotd-name include-slot)
	    (class-name class))))
      ;; Now separate all-slots into instance-slots and non instance-slots.
      (iterate ((slot in all-slots))
        (if (eq (slotd-allocation slot) :instance)
            (push slot instance-slots)
            (push slot non-instance-slots)))
      (values instance-slots non-instance-slots))))

(defmeth compute-class-precedence-list ((class essential-class) local-supers)
  (cons class
        (compute-class-precedence-list-internal--class
	  class class local-supers ())))

(defun compute-class-precedence-list-internal--class
       (root-class class supers inherit)
  (if (null supers)
      inherit
      (let* ((first-super (car supers))
             (rest-supers (compute-class-precedence-list-internal--class
			    root-class class (cdr supers) inherit))
             (first-super-supers (class-local-supers first-super))
             (temp (if (eq first-super root-class)
                       rest-supers
                       (compute-class-precedence-list-internal--class
			 root-class first-super
			 first-super-supers rest-supers))))
        (cond ((eq first-super root-class) temp)
              ((memq first-super temp) temp)
              (t (cons first-super temp))))))

(defmeth compute-method-inheritance-list ((class essential-class)
					  local-supers)
  (compute-class-precedence-list class local-supers))

(defmeth compatible-meta-class-change-p (class proto-new-class)
  (eq (class-of class) (class-of proto-new-class)))

(defmeth check-super-meta-class-compatibility (class new-super)
  (unless (eq (class-of class) (class-of new-super))
    (error "The class ~S was specified as a~%super-class of the class ~S;~%~
            but the meta-classes ~S and~%~S are incompatible."
	   new-super class (class-of new-super) (class-of class))))

(defun classp (x)
  (and (iwmc-class-p x) (typep--class x 'essential-class)))



(defmeth class-standard-constructor ((class basic-class))
  (dolist (constructor (ds-options-constructors (class-ds-options class)))
    (when (null (cdr constructor)) (return (car constructor)))))


(defmeth flush-class-caches ((class basic-class))
  (let ((wrapper (class-wrapper class)))
    (and wrapper (flush-class-wrapper-cache wrapper))
    (iterate ((subclass in (class-direct-subclasses class)))
      (flush-class-caches subclass))))


  ;;   
;;;;;; CHANGE-CLASS
  ;;   

(defmeth change-class ((object object) new-class)
  (let ((old-class (class-of object)))
    (unless (eq old-class new-class)
      (let ((pre-change-class (pre-change-class object)))
        (change-class-using-class old-class object new-class)
        (post-change-class object pre-change-class)))
    object))

(defmeth pre-change-class ((object object))
  (let ((class (class-of object)))
    (cons (iterate ((slotd in (class-instance-slots (class-of object))))
            (collect (slotd-name slotd))
            (collect (get-slot-using-class--class
                       class object (slotd-name slotd) () ())))
          (iwmc-class-dynamic-slots object))))

(defmeth post-change-class ((object object) pre-change-class)
  (let ((all-slots (append (car pre-change-class) (cdr pre-change-class))))
    (iterate ((name in all-slots by cddr)
              (value in (cdr all-slots) by cddr))
      (put-slot-always object name value))))

(defmeth change-class-using-class ((old-class basic-class)
				   self
				   (new-class basic-class))
  (ignore old-class)
  (setf (iwmc-class-class-wrapper self) (wrapper-of new-class)
        (iwmc-class-static-slots self) (%allocate-static-slot-storage--class
					 (class-no-of-instance-slots
					   new-class))
        (iwmc-class-dynamic-slots self) ()))

  ;;   
;;;;;; WITH
  ;;

;;; Make an alist whose entries are of the form:
;;; 
;;;   (<prefix+slot-name> <object-var> <class> <slotd>)
;;;
(defmeth expand-with-make-entries (method first-arg-to-with for)
  (let* ((entries ())
         (method-arguments
	   (when (method-p method)
	     (iterate ((arg in (method-arglist method))
		       (spec in (method-type-specifiers method)))
	       (when (classp spec) (collect (cons arg spec)))))))
    (iterate ((opc in first-arg-to-with))
      (or (listp opc) (setq opc (list opc)))
      (let* ((object (car opc))
             (prefix (cadr opc))
             (class
	       (or (and (caddr opc)
			(or (class-named (caddr opc) t)
			    (error "In ~S the class specified for ~S, ~S~%~%
                                    is not the name of a defined class."
				   for object (caddr opc))))
		   (and (not (variable-lexical-p object))
			(cdr (assq object method-arguments)))
		   (error "The class of the object bound to  ~S was not~%~
                           specified in the call to ~S, and could not be~%~
                           inferred automatically because ~A."
			  object
			  for
			  (if (variable-lexical-p object)
			      (format nil
				      "is bound around the call to ~S"
				      for)
			      "is not a type-specified argument")))))
        (iterate ((slotd in (class-slots class)))
          (push (list (if (or (null prefix)
                              (string-equal prefix ""))
                          (slotd-name slotd)
                          (intern (string-append prefix (slotd-name slotd))))
                      object
                      class
                      slotd)
                entries))))
    entries))

(defun with-get-fn (entry)
  `(,(slotd-accessor (nth 3 entry)) ,(nth 1 entry)))
(defun with-set-fn (entry new-val-form)
  `(setf (,(slotd-accessor (nth 3 entry)) ,(nth 1 entry)) ,new-val-form))
(defun with*-get-fn (entry)
  `(get-slot ,(nth 1 entry) ',(slotd-name (nth 3 entry))))
(defun with*-set-fn (entry new-val-form)
  `(setf (get-slot ,(nth 1 entry) ',(slotd-name (nth 3 entry)))
	 ,new-val-form))

(defmacro with (objects-prefixes-and-classes &body body)
  (expand-with
    objects-prefixes-and-classes body #'with-get-fn #'with-set-fn 'with))

(defmacro with* (objects-prefixes-and-classes &body body)
  (expand-with
    objects-prefixes-and-classes body #'with*-get-fn #'with*-set-fn 'with))

(defun expand-with (first-arg body get-fn set-fn for)
  (let ((entries (expand-with-make-entries *current-method* first-arg for)))
    (walk-form (cons 'progn body)
               :walk-function
               #'(lambda (form context &aux temp)
                   (cond ((and (symbolp form)
                               (eq context ':eval)
                               (null (variable-lexical-p form))
                               (null (variable-special-p form))
                               (setq temp (assq form entries)))
                          (funcall get-fn temp))
                         ((and (listp form)
                               (or (eq (car form) 'setq)
                                   (eq (car form) 'setf)))
                          (cond ((cdddr form)
                                 (cons 'progn
				   (iterate ((pair on (cdr form) by cddr))
				     (collect (list (car form)
						    (car pair)
						    (cadr pair))))))
                                ((setq temp (assq (cadr form) entries))
                                 (funcall set-fn temp (caddr form)))
                                (t form)))
                         (t form))))))


(defmacro with-let (objects-prefixes-and-classes &body body)
  (expand-with-let
    objects-prefixes-and-classes body #'with-get-fn #'with-set-fn 'with-let))

(defmacro with*-let (objects-prefixes-and-classes &body body)
  (expand-with-let
    objects-prefixes-and-classes body #'with*-get-fn #'with*-set-fn 'with*-let))

(defun expand-with-let (first-arg-to-with body get-fn set-fn for)
  (let* ((entries (expand-with-make-entries *current-method* first-arg-to-with for))
         (used-entries ())
         (walked-body (walk-form (cons 'progn body)
                                 :walk-function
				 #'(lambda (form context &aux temp)
				     (and (symbolp form)
					  (memq context '(eval set))
					  (setq temp (assq form entries))
					  (push temp used-entries))
				     form))))
    `(let ,(iterate ((used in used-entries))
             (collect (list (car used) (funcall get-fn used))))
       (unwind-protect ,walked-body
         ,@(iterate ((used in used-entries))
             (collect (funcall set-fn used (car used))))))))

(defun named-object-print-function (instance stream depth
					     &